home *** CD-ROM | disk | FTP | other *** search
/ Aminet 2 / Aminet AMIGA CDROM (1994)(Walnut Creek)[Feb 1994][W.O. 44790-1].iso / Aminet / util / gnu / GNU_TILE_FORTH.lha / tst / sets.tst < prev    next >
Text File  |  1992-05-19  |  1KB  |  68 lines
  1. .( Loading Sets test...) cr
  2.  
  3. #include blocks.f83
  4. #include sets.f83
  5.  
  6. sets blocks
  7.  
  8. .( 1: Set elements return pointers to the entry) cr
  9.  
  10. : element ( -- )
  11.   create last ,
  12. does> ( element -- entry)
  13.   @
  14. ;
  15.  
  16.  
  17. .( 2: A simple destructive copying function for sets) cr
  18.  
  19. : copy-set ( set1 set2 -- )
  20.   dup empty-set union-set
  21. ;
  22.  
  23.  
  24. .( 3: Color elements and some sets for calculations) cr
  25.  
  26. element white
  27. element black
  28.  
  29. element blue
  30. element red
  31. element yellow
  32.  
  33. element green
  34. element brown
  35. element violet
  36.  
  37. 10 set colors
  38.  
  39. { yellow red blue }    constant primary ( -- set)
  40. { green brown violet } constant secondary ( -- set)
  41.  
  42.  
  43. .( 4: The set of sets and a set print function) cr
  44.  
  45. { colors primary secondary } constant the-sets ( -- set)
  46.  
  47. : .sets ( -- )
  48.   ." { "
  49.   the-sets block[ execute .set ]; map-set
  50.   ." } "
  51. ;
  52.  
  53. .sets cr
  54.  
  55. .( 5: Testing the symbol set management) cr
  56.  
  57.  
  58. yellow colors add-set colors .set cr
  59. secondary colors copy-set colors .set cr
  60. brown colors remove-set colors .set cr
  61.  
  62. primary colors union-set colors .set cr
  63. blue colors remove-set colors .set cr
  64. { red brown blue green yellow } colors intersection-set colors .set cr
  65.  
  66. forth only
  67.  
  68.